home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The X-Philes (2nd Revision)
/
The X-Philes Number 1 (1995).iso
/
xphiles
/
hp48hor2
/
suite3d.src
< prev
next >
Wrap
Text File
|
1992-01-11
|
14KB
|
622 lines
%%HP: T(3)A(R)F(.);
@ SUITE3D by Charles Patton
DIR
VPAR
DIR
Xleft
0
Xright
3
Ynear
0
Yfar
3
Zlow
-1
Zhigh
2.5
XXleft
0
XXright
3
YYlow
0
YYhigh
3
Xe
2.5
Ye
-1.5
Ze
2
Nx
13
Ny
8
Hidden
0
END
SlopeField
\<< {VPAR Nx} RCL
{VPAR Ny} RCL
{VPAR Xleft} RCL {VPAR Xright} RCL DUP2 XRNG
{VPAR Ynear} RCL {VPAR Yfar} RCL DUP2 YRNG
EQ
0 0 0 0 0 0 0
\-> numx numy left right bot top der hstp vstp hofs vofs x y d
\<< ERASE {# 0d # 0d } PVIEW
right left - numx / 'hstp' STO
top bot - numy / 'vstp' STO
hstp .4 * 'hofs' STO
vstp .4 * 'vofs' STO
bot vstp 2 / + top
FOR y
y 'Y' STO
left hstp 2 / +
right
FOR x
x 'X' STO
der \->NUM 'd' STO
'IFTE(ABS(d*hofs)>vofs,vofs/d+i*vofs,hofs+i*hofs*d)' \->NUM
x y R\->C DUP2 + 3 ROLLD SWAP - line
hstp
STEP
vstp
STEP
\>>
{ X Y } PURGE { } PVIEW
\>>
psContour
\<< EQ
\<< \-> dx dy 'IFTE(dy==0,MAXR,-dx/dy)' \>>
\-> eq slp
\<<
IFERR eq X \.d
eq Y \.d
2 \->LIST
'slp' APPLY
{ X Y } SHOW STEQ
SlopeField
THEN eq STEQ ERRM DOERR
END eq STEQ
\>>
\>>
YView
\<< SetWindow 0
\<< \-> K
\<<
CASE
K TYPE DUP 0 ==
THEN
DROP X K R\->C
X -50 R\->C
DUP2 LINE TLINE
K
END
1 ==
THEN K
END
K EVAL 1 \->LIST
'PRASE' APPLY
END
\>>
\>> \-> Xleft Xright Ynear Yfar Xe Ye Ze Nx Ny prase u hline
\<< 'EQ' RCL
'u' \-> eq u
\<< eq { X '(X-Xe)*u+Xe' Y 'u+Ye' } |
Ze - 'u' / Ze +
{ X u } SHOW
COLCT
IF prase
THEN { & 'hline(&)' } \|vMATCH DROP
END
IFERR
'EQ' STO 'X' INDEP
ERASE
Ynear Yfar - 8 /
\-> stp
\<< Yfar Ye -
Ynear Ye -
FOR u
draw
IF KEY
THEN DROP
"outa here" DOERR
END
stp
STEP
\>>
THEN eq STEQ ERRM DOERR
ELSE eq STEQ
END
{ } PVIEW
\>>
\>>
\>>
WIREFRAME
\<< SetWindow 0 0 0 0
\-> Xmin Xmax Ynear Yfar Xe Ye Ze numx numy prase u v bd1 bd2
\<< 'u' 'v' \-> u v
\<< EQ { X v Y 'u+Ye' } |
Ze - 'u' / Ze +
{ v u } SHOW COLCT ERASE
{ # 0d # 0d } PVIEW
Ynear Yfar - numy /
Xmax Xmin - numx /
\-> eq stpu stpx
\<< Yfar Ye -
Ynear Ye -
FOR u
0 'bd1' STO
Xmin 'v' STO
0 numx
START
v Xe - u / Xe +
eq \->NUM R\->C
IF bd1
THEN DUP2 line
ELSE 1 'bd1' STO
END
IF bd2
THEN numx 2 + ROLL OVER line
END
stpx 'v' STO+
NEXT
1 'bd2' STO
stpu
STEP
numx 1 + DROPN
\>> { } PVIEW
\>>
\>>
\>>
ShapeToShade
\<< {VPAR Xleft} RCL
{VPAR Xright} RCL
{VPAR Ynear} RCL
{VPAR Yfar} RCL
0 0 0 \-> xmin xmax ymin ymax x y eq
\<< xmax xmin - 32 /
ymin ymax - 15.001 /
'x' 'y'
\-> xstp ystp x y
\<< EQ DUP
X \.d .4 - 2 ^ SWAP
Y \.d .4 + 2 ^ +
1 + -.35 ^
{ X x Y y } | COLCT
'eq' STO
ERASE {# 0d # 0d } PVIEW
# 0d
ymax ymin
FOR y
# 0d
xmin xmax
FOR x
DUP2 SWAP 2 \->LIST
PICT SWAP
eq \->NUM
IF
DUP TYPE 0 \=/
THEN
DROP 1
END
tile
15.99 * IP
DPAR SWAP 16 - NEG GET
REPL
4 +
xstp
STEP
DROP
4 +
ystp
STEP DROP { } PVIEW
\>>
\>>
\>>
Movie
\<< {VPAR Xleft} RCL {VPAR Xright} RCL XRNG
{VPAR Zlow} RCL {VPAR Zhigh} RCL YRNG
{VPAR Ynear} RCL {VPAR Yfar} RCL
{VPAR Ny} RCL
EQ
0 0
\-> ynear yfar numy eq ystp y
\<< 'y' 'y' STO
eq { X Y } SHOW
{ Y y } |
ynear yfar - numy / 'ystp' STO
IFERR STEQ
'X' INDEP
FUNCTION
0 yfar ynear
FOR y
ERASE draw
y PICT RCL ROT 2 +
IF KEY
THEN
DROP "outa here"
DOERR
END
ystp
STEP
THEN
eq STEQ
ERRM DOERR
END
eq STEQ
\>> uSMOV
\>>
uSMOV
\<< \-> n
\<< { # 0d # 0d } PVIEW
DO n ROLL
n ROLL
DUP PICT {# 0d # 0d } ROT REPL
UNTIL KEY
END DROP n
\>>
\>>
SSTMovie
\<<
DO
\-> n
\<< n ROLL n ROLL DUP PICT
{# 0d # 0d } ROT REPL n
{ # 0d # 0d } PVIEW
\>>
UNTIL 0 WAIT
51.1 ==
END
\>>
GRIDMAP
\<< EQ PPAR VPAR Xleft Xright Ynear Yfar
XXright XXleft YYlow YYhigh Nx Ny
UPDIR
\-> eq pp X1 X2 Y1 Y2 xr1 xr2 yr1 yr2 NX NY
\<< X2 X1 -
Y2 Y1 -
\-> DX DY
\<< eq { X
'X1+DX*(1+INV(NX-1))*
(.5+(-1)^IP(NY*((1-INV(NX*NY))*TTT+.5/(NX*NY)))*
(-.5+FP(NY*((1-INV(NX*NY))*TTT+.5/(NX*NY)))))-
.5*(DX/(NX-1))'
Y
'Y1+DY/(NY-1)*IP(NY*((1-INV(NX*NY))*TTT+.5/(NX*NY)))'
} | { TTT } SHOW
eq { X
'X1+DX/(NX-1)*IP(NX*((1-INV(NY*NX))*TTT+.5/(NY*NX)))'
Y
'Y1+DY*(1+INV(NY-1))*
(.5+(-1)^IP(NX*((1-INV(NY*NX))*TTT+.5/(NY*NX)))*
(-.5+FP(NX*((1-INV(NY*NX))*TTT+.5/(NY*NX)))))-
.5*(DY/(NY-1))'
} | { TTT } SHOW
SWAP
IFERR { TTT 0 1 } INDEP
PARAMETRIC
xr1 xr2 XRNG
yr1 yr2 YRNG
NX NY * 1 - INV RES
STEQ
ERASE pardraw
STEQ pardraw
{ } PVIEW
pp 'PPAR' STO eq STEQ
THEN eq STEQ pp 'PPAR' STO
ERRM DOERR
END
\>>
\>>
\>>
DPAR {
GROB 4 4 00400000
GROB 4 4 00402000
GROB 4 4 90000080
GROB 4 4 40104010
GROB 4 4 20802090
GROB 4 4 8050A010
GROB 4 4 50A05080
GROB 4 4 A050A050
GROB 4 4 50A050A0
GROB 4 4 A050A070
GROB 4 4 70A050E0
GROB 4 4 D070D060
GROB 4 4 B0E0B0E0
GROB 4 4 70D0F0B0
GROB 4 4 F0B0D0F0
GROB 4 4 F0B0F0F0 }
EQ
'2*(2-Y)*EXP(-((X-.5)^2+(Y-1.2)^2))+Y*EXP(-2*((X-2)^2+(Y-2)^2))'
PPAR
{ (-2,0) (2,5) X # 8d (0,0) FUNCTION Y }
SetWindow
\<< PATH
VPAR
Xleft Xright Ynear Yfar Zlow Zhigh Xe Ye Ze Nx Ny Hidden 0
\-> Xleft Xright Ynear Yfar Zlow Zhigh Xe Ye Ze Nx Ny Hidden Ue
\<< EVAL
\<< \-> u y '(u-Ue)/(y-Ye)+Ue' SWAP OVER MAX ROT ROT MIN SWAP \>>
\-> proj
\<< Xe 'Ue' STO
MAXR \->NUM DUP NEG
Xleft Ynear proj EVAL
Xleft Yfar proj EVAL
Xright Ynear proj EVAL
Xright Yfar proj EVAL
XRNG
Ze 'Ue' STO
MAXR \->NUM DUP NEG
Zlow Ynear proj EVAL
Zlow Yfar proj EVAL
Zhigh Ynear proj EVAL
Zhigh Yfar proj EVAL
YRNG
\>>
Xleft Xright Ynear Yfar Xe Ye Ze Nx Ny Hidden
\>>
\>>
draw
DRAW
line
LINE
tile
\<< \>>
pardraw
DRAW
@ Begin POSTSCRIPT Stuff @
PSTOGGLE
\<< "PS is "
IF 'draw' RCL 'PSDRAW' SAME
THEN { DRAW } 1 GET DUP 'draw' STO
'pardraw' STO
{ LINE } 1 GET 'line' STO
\<< \>> 'tile' STO
"Off" +
ELSE 'PSDRAW' 'draw' STO
'PSLINE' 'line' STO
'PSTILE' 'tile' STO
'PSPARDRAW' 'pardraw' STO
"On" +
END 1 DISP
\>>
PSRESET
\<< "'PSOUT" 'PSOUT'
DO "" SWAP STO
"&" + DUP STR\-> DUP
UNTIL VTYPE -1 ==
END
DROP2 'PSOUT' 'CURRENTOUT' STO
\>>
PSTILE
\<< DUP \->STR
" g
"
+ 5 PICK B\->R
DUP 4 + \->STR " " +
SWAP \->STR " " +
8 PICK # 64d SWAP - B\->R
DUP 4 - \->STR
" " + SWAP \->STR " " +
\-> X2 X1 Y1 Y2
\<< X2 + Y1 +
"m
"
+ X2 + Y2 +
"L
"
+ X1 + Y2 +
"L
"
+ X1 + Y1 +
"L
"
+ X2 + Y1 +
"L
f
"
+
\>> PSADDTO
\>>
PSADDTO
\<<
IF CURRENTOUT SIZE 4000 >
THEN 'CURRENTOUT' RCL \->STR
1 OVER SIZE 1 - SUB "&" + STR\->
DUP 'CURRENTOUT' STO STO
ELSE
'CURRENTOUT' RCL SWAP STO+
END
\>>
CURRENTOUT
PSOUT
PSCOPAIR
\<< 'PPAR(1)' EVAL DUP
'PPAR(2)' EVAL SWAP -
\-> p1 p2 o d
\<< p2 o - C\->R
d C\->R ROT SWAP / 64 *
ROT ROT / 131 *
p1 o - C\->R d C\->R
ROT SWAP / 64 *
ROT ROT / 131 *
\>> \-> y2 x2 y1 x1
\<< x1 \->STR " " +
y1 \->STR " " + +
x2 \->STR " " + +
y2 \->STR " " + +
x2 x1 - x2 + \->STR " " +
y2 y1 - y2 + \->STR " " + +
\>>
\>>
PSDRAW
\<< PPAR OBJ\-> 4 DROPN
0 0
\-> hm vm indp rs flop \Gdx
\<<
IF rs TYPE 10 ==
THEN rs # 0d 2 \->LIST PX\->C hm - RE
ELSE
IF rs 0 ==
THEN { # 1d # 0d } PX\->C hm - RE
ELSE rs
END
END
3 / '\Gdx' STO
'EQ' RCL 'vm' STO
\<< \-> vl
\<< vl \->NUM
indp \->NUM
\-> vlu indv
\<<
IF flop
THEN indv \Gdx - vl indp \.d \->NUM
\Gdx *
vlu SWAP - R\->C
'indp+vl*i' \->NUM PSCOPAIR
3 ROLLD + "c
"
+
PSADDTO
ELSE
'indp+vl*i' \->NUM
PSCO "m
"
+
indv \Gdx +
vl indp \.d \->NUM
\Gdx * vlu + R\->C PSCO +
1 'flop' STO
END
vlu
\>>
\>>
\>> 'hm' STO
IFERR vm {& 'hm(QUOTE(&))' } \|vMATCH DROP STEQ
DRAW vm STEQ
THEN vm STEQ ERRM DOERR
END "S
"
PSADDTO
\>>
\>>
PSPARDRAW
\<< 'PPAR(3)' EVAL OBJ\-> DROP 'PPAR(4)' EVAL 0 0
\->indp hm vm rs flop \Gdx
\<<
IF rs 0 ==
THEN # 1d 'rs' STO
END
IF rs TYPE 10 ==
THEN rs B\->R 131 / vm hm - *
ELSE rs
END 3 / '\Gdx' STO 'EQ' RCL 'vm' STO
\<< \-> vl
\<< vl \->NUM indp \->NUM
\-> vlu indv
\<<
IF flop
THEN vl indp \.d \->NUM \Gdx * vlu SWAP - (0,0) + vlu (0,0) +
PSCOPAIR 3 ROLLD +
"c
" + PSADDTO
ELSE vlu (0,0) + PSCO
"m
"
+ vl indp \.d \->NUM \Gdx * vlu + (0,0) + PSCO +
1 'flop' STO
END
vlu
\>>
\>>
\>> 'hm' STO
IFERR vm { & 'hm(QUOTE(&))' } \|vMATCH DROP STEQ
DRAW vm STEQ
THEN vm STEQ ERRM DOERR
END
"S
"
PSADDTO
\>>
\>>
PSCO
\<< 'PPAR(1)' EVAL - C\->R
'PPAR(2)-PPAR(1)' EVAL C\->R
ROT SWAP / 64 *
ROT ROT / 131 * \->STR
" " + SWAP \->STR
" " + +
\>>
PSLINE
\<< \-> C1 C2
\<< C1 PSCO
"m
"
+ C2 PSCO +
"l
S
"
+ PSADDTO
C1 C2 LINE
\>>
\>>
derMOD
\<< \-> K L DK DL 'DK' \>>
derIP
\<< \-> K DK '0' \>>
derIM
\<< \-> K DK 'IM(DK)' \>>
derRE
\<< \-> K DK 'RE(DK)' \>>
PSOUT
""
PSOUT&
""
PSOUT&&
""
PSOUT&&&
""
PSOUT&&&&
""
PSOUT&&&&&
""
PSOUT&&&&&&
""
END